home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / basecalc.arc / BASECALC.PAS
Pascal/Delphi Source File  |  1986-03-19  |  17KB  |  527 lines
  1.   { name:            Charles Jackson, SJ
  2.     date:            11 January 1986
  3.     computer:        IBM-PC (256K) / PC-DOS ver 2.1
  4.     Pascal compiler: Turbo Pascal (ver 3.0)
  5.     file name:       BASECALC.PAS }
  6.  
  7. program Base_Calculator(input,output);
  8.  
  9.   const
  10.     stack_register_size = 60;
  11.   type
  12.     stack_register_type = string[stack_register_size];
  13.     digit_type = array[0..15] of char;
  14.   const
  15.     clear_register =
  16.       '00000000 00000000       00000          0000               ..';
  17.     register_line = 11;
  18.     register_column = 8;
  19.     menu_line = 17;
  20.     quit_command = 'Q';
  21.     digit : digit_type = ('0','1','2','3','4','5','6','7','8','9',
  22.                           'A','B','C','D','E','F');
  23.     base_2_size = 16;
  24.     base_10_size = 5;
  25.     base_16_size = 4;
  26.     ascii_size = 2;
  27.     base_2_end = 17;
  28.     base_10_end = 29;
  29.     base_16_end = 43;
  30.     ascii_end = 60;
  31.     negative_position = 24;
  32.   type
  33.     str_80 = string[80];
  34.     str_20 = string[20];
  35.     stack_type = array[0..3] of stack_register_type;
  36.     real_value_stack_type = array[0..3] of real;
  37.     valid_command_set = set of char;
  38.   var
  39.     stack : stack_type;
  40.     real_value_stack : real_value_stack_type;
  41.     base : byte;
  42.     command : char;
  43.  
  44.   procedure Print(s : str_80; x, y : byte);
  45.     begin
  46.       GotoXY(x,y);
  47.       write(s);
  48.     end; {Print}
  49.  
  50.   procedure Print_Rectangle;
  51.     var
  52.       line : byte;
  53.     begin
  54.       ClrScr;
  55.       LowVideo;
  56.       Print('┌──────────────────────────────────────────────────────────'
  57.         + '────────┬──────────┐',1,5);
  58.       Print('│                        Base Calculator                   '
  59.         + '        │ Base:    │',1,6);
  60.       Print('├──────────────────────────────────────────────────────────'
  61.         + '────────┴──────────┤',1,7);
  62.       Print('│',1,8);
  63.       Print('│',79,8);
  64.       Print('│           Binary            Decimal     Hexadecimal      '
  65.         + '    ASCII          │',1,9);
  66.       for line := 10 to 15 do
  67.         begin
  68.           Print('│',1,line);
  69.           Print('│',79,line);
  70.         end;
  71.       Print('├──────────────────────────────────────────────────────────'
  72.         + '───────────────────┤',1,16);
  73.       Print('│',1,17);
  74.       Print('│',79,17);
  75.       Print('└──────────────────────────────────────────────────────────'
  76.         + '───────────────────┘',1,18);
  77.     end; {Print_Rectangle}
  78.  
  79.   procedure Print_Register(register : byte);
  80.     begin
  81.       HighVideo;
  82.       GotoXY(register_column,register_line + register);
  83.       write(stack[register]);
  84.     end; {Print_Register}
  85.  
  86.   procedure Initialize;
  87.     var
  88.       register : byte;
  89.     begin
  90.       base := 10;
  91.       HighVideo;
  92.       GotoXY(76,6);
  93.       write(base,' ');
  94.       for register := 0 to 3 do
  95.         begin
  96.           stack[register] := clear_register;
  97.           real_value_stack[register] := 0;
  98.           Print_Register(register);
  99.         end;
  100.     end; {Initialize}
  101.  
  102.   procedure Push(stack_register : stack_register_type; value : real);
  103.     var
  104.       register : byte;
  105.     begin
  106.       for register := 3 downto 0 do
  107.         begin
  108.           if register > 0
  109.             then stack[register] := stack[register-1]
  110.             else stack[register] := stack_register;
  111.           if register > 0
  112.             then real_value_stack[register] := real_value_stack[register-1]
  113.             else real_value_stack[register] := value;
  114.           Print_Register(register);
  115.         end;
  116.     end; {Push}
  117.  
  118.   procedure Pop;
  119.     var
  120.       register : byte;
  121.     begin
  122.       for register := 0 to 3 do
  123.         begin
  124.           if register < 3
  125.             then stack[register] := stack[register+1]
  126.             else stack[register] := clear_register;
  127.           if register < 3
  128.             then real_value_stack[register] := real_value_stack[register+1]
  129.             else real_value_stack[register] := 0;
  130.         end;
  131.     end; {Pop}
  132.  
  133.   procedure Get_Valid_Command(var command : char;
  134.                               column : byte;
  135.                               valid_commands : valid_command_set);
  136.     begin
  137.       repeat
  138.         GotoXY(column,menu_line);
  139.         read(kbd,command);
  140.       until command in valid_commands;
  141.       if command > 'Z'
  142.         then command := chr(ord(command) - 32);
  143.     end; {Get_Valid_Command}
  144.  
  145.   procedure Clear_Command_Line;
  146.     begin
  147.       GotoXY(2,menu_line);
  148.       write(' ':77);
  149.     end; {Clear_Command_Line}
  150.  
  151.   procedure Get_Value_String(var input_string : str_20;
  152.                              var value_size : byte;
  153.                              base : byte;
  154.                              var quit : boolean);
  155.     const
  156.       backspace = #8;
  157.       return = #13;
  158.       space = #32;
  159.     var
  160.       ch : char;
  161.       index, max_value_size : byte;
  162.       valid_digits : set of char;
  163.     begin
  164.       case base of
  165.         2  : begin
  166.                max_value_size := base_2_size;
  167.                valid_digits := ['0','1'];
  168.              end;
  169.         10 : begin
  170.                max_value_size := base_10_size;
  171.                valid_digits := ['0'..'9'];
  172.              end;
  173.         16 : begin
  174.                max_value_size := base_16_size;
  175.                valid_digits := ['0'..'9','A'..'F','a'..'f'];
  176.              end;
  177.       end;
  178.       value_size := 0;
  179.       input_string := '00000000000000000000';
  180.       repeat
  181.         read(kbd,ch);
  182.         if (ch in valid_digits) and (value_size < max_value_size) then
  183.           begin
  184.             value_size := value_size + 1;
  185.             if ch in ['a'..'z']
  186.               then ch := chr(ord(ch) - 32);
  187.             input_string[value_size] := ch;
  188.             write(ch);
  189.           end;
  190.         if (ch = backspace) and (value_size > 0) then
  191.           begin
  192.             write(backspace,space,backspace);
  193.             value_size := value_size - 1;
  194.           end;
  195.         quit := (ch = 'q') or (ch = 'Q');
  196.       until (ch = return) or quit;
  197.     end; {Get_Value_String}
  198.  
  199.   procedure Store_Value_String(var register : stack_register_type;
  200.                                input_string : str_20;
  201.                                value_size, base : byte);
  202.     var
  203.       register_index, input_index : byte;
  204.     begin
  205.       case base of
  206.         2  : register_index := base_2_end;
  207.         10 : register_index := base_10_end;
  208.         16 : register_index := base_16_end;
  209.       end;
  210.       for input_index := value_size downto 1 do
  211.         begin
  212.           if register_index = 9
  213.             then register_index := register_index - 1;
  214.           register[register_index] := input_string[input_index];
  215.           register_index := register_index - 1;
  216.         end;
  217.     end; {Store_Value_String}
  218.  
  219.   function digit_value(d : char) : integer;
  220.     begin
  221.       case d of
  222.         '0'..'9' : digit_value := ord(d) - ord('0');
  223.         'A'..'F' : digit_value := ord(d) - 55;
  224.       end;
  225.     end; {digit_value}
  226.  
  227.   procedure Get_Real_Value(var real_value: real;
  228.                            input_string : str_20;
  229.                            value_size, base : byte);
  230.     var
  231.       index : byte;
  232.       multiplier : real;
  233.     begin
  234.       real_value := 0;
  235.       multiplier := 1;
  236.       for index := value_size downto 1 do
  237.         begin
  238.           real_value := real_value
  239.                         + (digit_value(input_string[index]) * multiplier);
  240.           multiplier := multiplier * base;
  241.         end;
  242.     end; {Get_Real_Value}
  243.  
  244.   procedure Convert_Base_10(var register : stack_register_type;
  245.                             real_value : real);
  246.     var
  247.       index : byte;
  248.       convert_string : str_20;
  249.     begin
  250.       Str(real_value:20:0,convert_string);
  251.       index := 20;
  252.       while convert_string[index] <> ' ' do
  253.         begin
  254.           if convert_string[index] = '-'
  255.             then register[negative_position] := '-'
  256.             else register[index+9] := convert_string[index];
  257.           index := index - 1;
  258.         end;
  259.     end; {Convert_Base_10}
  260.  
  261.   function remainder(real_value : real; convert_base : integer) : char;
  262.     var
  263.       integer_remainder : byte;
  264.     begin
  265.       integer_remainder := trunc(real_value - (int(real_value/convert_base)
  266.                                               * convert_base));
  267.       remainder := digit[integer_remainder];
  268.     end; {remainder}
  269.  
  270.   procedure Convert_Value_String(var register : stack_register_type;
  271.                                  real_value : real;
  272.                                  convert_base, end_position, quit : byte);
  273.     var
  274.       index : byte;
  275.     begin
  276.       index := end_position;
  277.       while (real_value <> 0) and (index > quit) do
  278.         begin
  279.           register[index] := remainder(real_value,convert_base);
  280.           index := index - 1;
  281.           if index = 9
  282.             then index := index - 1;
  283.           real_value := int(real_value / convert_base);
  284.         end;
  285.     end; {Convert_Value_String}
  286.  
  287.   procedure Convert_ASCII(var register : stack_register_type; real_value : real);
  288.     var
  289.       left, right : byte;
  290.     begin
  291.       right := trunc(real_value - int(real_value/256) * 256);
  292.       left := trunc(real_value / 256);
  293.       if right >= 32
  294.         then register[ascii_end] := chr(right);
  295.       if left >= 32
  296.         then register[ascii_end-1] := chr(left);
  297.     end; {Convert_ASCII}
  298.  
  299.   procedure Store_Value(input_string : str_20; value_size, base : byte);
  300.     var
  301.       real_value : real;
  302.       register : stack_register_type;
  303.     begin
  304.       register := clear_register;
  305.       Store_Value_String(register,input_string,value_size,base);
  306.       Get_Real_Value(real_value,input_string,value_size,base);
  307.       case base of
  308.         2  : begin
  309.                Convert_Base_10(register,real_value);
  310.                Convert_Value_String(register,real_value,16,base_16_end,40);
  311.              end;
  312.         10 : begin
  313.                Convert_Value_String(register,real_value,2,base_2_end,1);
  314.                Convert_Value_String(register,real_value,16,base_16_end,40);
  315.              end;
  316.         16 : begin
  317.                Convert_Value_String(register,real_value,2,base_2_end,1);
  318.                Convert_Base_10(register,real_value);
  319.              end;
  320.       end;
  321.       Convert_ASCII(register,real_value);
  322.       Push(register,real_value);
  323.     end; {Store_Value}
  324.  
  325.   procedure Enter_Value_Main;
  326.     var
  327.       input_string : str_20;
  328.       value_size : byte;
  329.       quit : boolean;
  330.     begin
  331.       repeat
  332.         HighVideo;
  333.         Clear_Command_Line;
  334.         LowVideo;
  335.         GotoXY(17,menu_line);
  336.         write('Enter base ',base,' value:');
  337.         Print('( )uit.',56,menu_line);
  338.         HighVideo;
  339.         Print('Q',57,menu_line);
  340.         GotoXY(38,menu_line);
  341.         Get_Value_String(input_string,value_size,base,quit);
  342.         if not quit then
  343.           Store_Value(input_string,value_size,base);
  344.       until quit;
  345.     end; {Enter_Value_Main}
  346.  
  347.   procedure Print_Operation_Menu(var command : char);
  348.     begin
  349.       LowVideo;
  350.       Clear_Command_Line;
  351.       Print('( )ND  ( )R  ( )OR  ( )EG',11,menu_line);
  352.       Print('.  ( )uit.',48,menu_line);
  353.       HighVideo;
  354.       Print('A',12,menu_line);
  355.       Print('O',19,menu_line);
  356.       Print('X',25,menu_line);
  357.       Print('N',32,menu_line);
  358.       Print('Q',52,menu_line);
  359.       Print('+  -  *  /',38,menu_line);
  360.       Print('Command:',60,menu_line);
  361.       Get_Valid_Command(command,69,
  362.         ['A','a','O','o','X','x','N','n','Q','q','+','-','*','/']);
  363.     end; {Print_Operation_Menu}
  364.  
  365.   procedure Do_Logic_Operation(operation : char);
  366.     var
  367.       register : stack_register_type;
  368.       value_string : str_20;
  369.       index, value_string_index : byte;
  370.       real_value : real;
  371.       test : boolean;
  372.     begin
  373.       value_string := '00000000000000000000';
  374.       register := clear_register;
  375.       index := base_2_end;
  376.       value_string_index := 16;
  377.       repeat
  378.         case operation of
  379.           'A' : test := (stack[0][index] = '1') and (stack[1][index] = '1');
  380.           'O' : test := (stack[0][index] = '1') or (stack[1][index] = '1');
  381.           'X' : test := stack[0][index] <> stack[1][index];
  382.         end;
  383.         if test
  384.           then value_string[value_string_index] := '1'
  385.           else value_string[value_string_index] := '0';
  386.         if value_string[value_string_index] = '1'
  387.           then register[index] := '1';
  388.         value_string_index := value_string_index - 1;
  389.         if index = 9
  390.           then index := index - 2
  391.           else index := index - 1;
  392.       until index = 0;
  393.       Get_Real_Value(real_value,value_string,base_2_size,2);
  394.       Convert_Base_10(register,real_value);
  395.       Convert_Value_String(register,real_value,16,base_16_end,40);
  396.       Convert_ASCII(register,real_value);
  397.       Pop;
  398.       Pop;
  399.       Push(register,real_value);
  400.     end; {Do_Logic_Operation}
  401.  
  402.   procedure Store_Negative(real_value : real);
  403.     var
  404.       register : stack_register_type;
  405.       twos_complement : real;
  406.     begin
  407.       register := clear_register;
  408.       Convert_Base_10(register,real_value);
  409.       twos_complement := 65536.0 + real_value;
  410.       Convert_Value_String(register,twos_complement,2,base_2_end,1);
  411.       Convert_Value_String(register,twos_complement,16,base_16_end,40);
  412.       Convert_ASCII(register,twos_complement);
  413.       Pop;
  414.       Push(register,real_value);
  415.     end; {Store_Negative}
  416.  
  417.   procedure Do_Arithmetic_Operation(operation : char);
  418.     var
  419.       register : stack_register_type;
  420.       real_value : real;
  421.     begin
  422.       case operation of
  423.         'A' : real_value := real_value_stack[0] + real_value_stack[1];
  424.         'S' : real_value := real_value_stack[1] - real_value_stack[0];
  425.         'M' : real_value := real_value_stack[0] * real_value_stack[1];
  426.         'D' : if real_value_stack[0] <> 0
  427.                 then real_value :=
  428.                   int(real_value_stack[1] / real_value_stack[0])
  429.                 else real_value := 0;
  430.       end;
  431.       if real_value < 0
  432.         then
  433.           begin
  434.             Pop;
  435.             Store_Negative(real_value)
  436.           end
  437.         else
  438.           begin
  439.             register := clear_register;
  440.             Convert_Value_String(register,real_value,2,base_2_end,1);
  441.             Convert_Base_10(register,real_value);
  442.             Convert_Value_String(register,real_value,16,base_16_end,40);
  443.             Convert_ASCII(register,real_value);
  444.             Pop;
  445.             Pop;
  446.             Push(register,real_value);
  447.           end;
  448.     end; {Do_Arithmetic_Operation}
  449.  
  450.   procedure Enter_Operation_Main;
  451.     var
  452.       command : char;
  453.     begin
  454.       repeat
  455.         Print_Operation_Menu(command);
  456.         if command <> quit_command then
  457.           case command of
  458.             'A' : Do_Logic_Operation('A');
  459.             'O' : Do_Logic_Operation('O');
  460.             'X' : Do_Logic_Operation('X');
  461.             'N' : Store_Negative(-real_value_stack[0]);
  462.             '+' : Do_Arithmetic_Operation('A');
  463.             '-' : Do_Arithmetic_Operation('S');
  464.             '*' : Do_Arithmetic_Operation('M');
  465.             '/' : Do_Arithmetic_Operation('D');
  466.           end;
  467.       until command = quit_command;
  468.     end; {Enter_Operation_Main}
  469.  
  470.   procedure Set_Base_Main;
  471.     var
  472.       input_string : str_20;
  473.       real_value : real;
  474.       value_size : byte;
  475.       quit : boolean;
  476.     begin
  477.       repeat
  478.         HighVideo;
  479.         Clear_Command_Line;
  480.         LowVideo;
  481.         Print('Enter base: <2,10,16>:',22,menu_line);
  482.         Print('( )uit.',51,menu_line);
  483.         HighVideo;
  484.         Print('Q',52,menu_line);
  485.         GotoXY(45,menu_line);
  486.         Get_Value_String(input_string,value_size,10,quit);
  487.         if not quit then
  488.           begin
  489.             Get_Real_Value(real_value,input_string,value_size,10);
  490.             base := trunc(real_value);
  491.             if base in [2,10,16] then
  492.               begin
  493.                 GotoXY(76,6);
  494.                 write(base,' ');
  495.               end;
  496.           end;
  497.       until (base in [2,10,16]) or quit;
  498.     end; {Set_Base_Main}
  499.  
  500.   procedure Print_Main_Menu(var command : char);
  501.     begin
  502.       Clear_Command_Line;
  503.       LowVideo;
  504.       Print('Enter ( )alue/( )peration/( )ase.  ( )uit.',14,menu_line);
  505.       HighVideo;
  506.       Print('V',21,menu_line);
  507.       Print('O',29,menu_line);
  508.       Print('B',41,menu_line);
  509.       Print('Q',50,menu_line);
  510.       Print('Command:',58,menu_line);
  511.       Get_Valid_Command(command,67,['V','v','O','o','B','b','Q','q']);
  512.     end; {Print_Main_Menu}
  513.  
  514.   begin
  515.     Print_Rectangle;
  516.     Initialize;
  517.     repeat
  518.       Print_Main_Menu(command);
  519.       if command <> quit_command then
  520.         case command of
  521.           'V' : Enter_Value_Main;
  522.           'O' : Enter_Operation_Main;
  523.           'B' : Set_Base_Main;
  524.         end;
  525.     until command = quit_command;
  526.     GotoXY(1,23);
  527.   end. {Base_Calculator}